perm filename MORSED.F4[HAK,HPM] blob
sn#004570 filedate 1974-06-17 generic text, type T, neo UTF8
00100 DIMENSION LPHA(36),MORS(36)
00200 DATA LNUM/36/
00300 COMMON/PARS/AVCS,AVWS,AVOM,AVAM
00400 DATA AVSP/3.5/,AVWS/7./,AVOM/3.5/,AVAM/7./
00500 DIMENSION IMAR(7),ISPA(7),ITYP(7),IMTYP(7)
00600 DATA LPHA/'E','T','I','A','N','M','S','U','R','W','D'
00700 1,'K','G','O','H','V','F','L','P','J','B','X','C','Y','Z','Q'
00800 2,'5','4','3','2','1','6','7','8','9','0'/
00900 DATA MORS/1,2,4,5,7,8,13,14,16,17,22,23,25,26,40,41,43,49
01000 1,52,53,67,68,70,71,76,77,121,122,125,134,161,202,229
01100 2,238,241,242/
01200 10 CALL LETR(IMAR,ISPA,ITYP,IMTYP,N)
01300 NLEF=N
01400 CALL MAXM(N,IMAR,MIN,MAX)
01500 IF(2*MIN.GT.MAX) GO TO 1
01600 AVOM=AVOM*0.5+0.5*MIN
01700 AVAM=AVAM*0.5+0.5*MAX
01800 1 DO 2 I=1,N
02000 IF(IMAR(I)*2.0.GT.AVOM+AVAM) GO TO 3
02100 IMTYP(I)=1
02200 AVOM=AVOM*0.9+0.1*IMAR(I)
02300 GO TO 2
02400 3 IMTYP(I)=2
02500 AVAM=AVAM*0.9+0.1*IMAR(I)
02600 2 CONTINUE
02700 12 ICHR=0
02800 DO 4 I=1,N
02900 4 ICHR=ICHR*3+IMTYP(I)
03000 I=1
03100 J=LNUM
03200 6 IF(I.GT.J) GO TO 5
03300 K=(I+J)/2
03400 IF(MORS(K)-ICHR) 9,8,7
03500 7 J=K-1
03600 GO TO 6
03700 9 I=K+1
03800 GO TO 6
03900 8 IF(ITYP(1).EQ.4) CALL CRET
04000 IF(ITYP(1).EQ.3) CALL CHAR(' ')
04100 CALL CHAR(LPHA(K))
04200 NLEF=NLEF-N
04300 DO 20 I=1,N
04400 IF(ITYP(I).EQ.1) AVCS=AVCS*0.99-0.01*ISPA(I)
04500 IF(ITYP(I).EQ.2) AVWS=AVWS*0.99-0.01*ISPA(I)
04600 20 CONTINUE
04700 IF(NLEF.EQ.0) GO TO 10
04800 DO 11 I=1,NLEF
04900 K=I+N
05000 IMAR(I)=IMAR(K)
05100 ISPA(I)=ISPA(K)
05200 ITYP(I)=ITYP(K)
05300 11 IMTYP(I)=IMTYP(K)
05400 N=NLEF
05500 GO TO 12
05600 5 CALL MAXM(N-1,ISPA(2),MAX,MIN)
05700 DO 13 I=2,N
05800 IF(ISPA(I).EQ.MAX) GO TO 14
05900 13 CONTINUE
06000 14 ITYP(I)=2
06100 N=I-1
06200 GO TO 12
06300 END
06400
06500 SUBROUTINE LETR(IMAR,ISPA,ITYP,IMTYP,N)
06600 DIMENSION IMAR(7),ISPA(7),ITYP(7),IMTYP(7)
06700 INTEGER MARK(10),SPACE(10),SPATYP(10)
06800 DATA ILAS/0/
06900 COMMON/PARS/ AVCS,AVWS,AVOM,AVAM
07000 5 SPATYP(ILAS+1)=0
07100 CALL NEXT(-100,SPACE(ILAS+1),IFY)
07150 IF(SPACE(ILAS+1).GT.0) GO TO 5
07200 IF(IFY.NE.2) GO TO 4
07300 SPACE(ILAS+1)=-AVWS
07400 SPATYP(ILAS+1)=4
07500 4 CALL NEXT(200,MARK(ILAS+1),IFY)
07600 IF(IFY.EQ.2) GO TO 5
07700 ILAS=ILAS+1
07800 IMTYP(ILAS)=0
07900 IF(ILAS.LT.6) GO TO 5
08000 CALL MAXM(ILAS-1,SPACE(2),MAX,MIN)
08100 AVCS=AVCS*0.95-0.05*MIN
08200 IF(-4*MIN.GT.-MAX) AVWS=AVWS*0.7-0.3*MAX
08300 DO 6 I=1,ILAS
08400 IF(SPATYP(I).NE.0) GO TO 6
08500 SPATYP(I)=1
08600 IF(-SPACE(I).GT.0.6*(AVCS+AVWS)) SPATYP(I)=2
08700 IF(SPACE(I).EQ.MAX) SPATYP(I)=2
08800 IF(SPACE(I).GT.1.3*AVWS) SPATYP(I)=3
08900 IF(SPACE(I).EQ.MIN) SPATYP(I)=1
09000 6 CONTINUE
09010 IMAR(1)=MARK(1)
09020 ISPA(1)=SPACE(1)
09030 ITYP(1)=SPATYP(1)
09100 DO 7 I=2,ILAS
09200 IF(SPATYP(I).NE.1) GO TO 8
09300 IMAR(I)=MARK(I)
09400 ISPA(I)=SPACE(I)
09500 ITYP(I)=SPATYP(I)
09600 7 CONTINUE
09700 8 N=I-1
09800 DO 9 J=I,ILAS
09900 K=J-I+1
10000 SPATYP(K)=SPATYP(J)
10100 IF(J.NE.I) SPATYP(K)=0
10200 SPACE(K)=SPACE(J)
10300 9 MARK(K)=MARK(J)
10400 ILAS=ILAS-N
10500 RETURN
10600 END
10700
10800 SUBROUTINE MAXM(N,IR,MIN,MAX)
10900 DIMENSION IR(N)
11000 MAX=IR(1)
11100 MIN=MAX
11200 DO 1 I=1,N
11300 IF(IR(I).LT.MIN) MIN=IR(I)
11400 IF(IR(I).GT.MAX) MAX=IR(I)
11500 1 CONTINUE
11600 RETURN
11700 END
11800
11900 SUBROUTINE NEXT(MAX,LEN,IFY)
12000 COMMON/HREE/IGG
12100 DIMENSION IN(200)
12200 DATA IG/1/,I/1/,LEG/200/
12300 IFY=1
12400 GO TO (1,2),IG
12500 1 CALL MORSIN(IN,LEG)
12600 IG=2
12700 2 IF(IGG.NE.0.AND.IGG.NE.I) GO TO 4
12800 IF(IABS(IN(I)).GT.IABS(MAX)) GO TO 3
12900 CALL SLEEP(0)
13000 GO TO 2
13100 4 LEN=IN(I)
13200 I=MOD(I,LEG)+1
13300 IF(LEN*MAX.LT.0) GO TO 2
13400 RETURN
13500 3 LEN=IN(I)
13600 IFY=2
13700 CALL SLEEP(0)
13800 RETURN
13900 END